home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #15 / Monster Media Number 15 (Monster Media)(July 1996).ISO / prog_d / isamexpt.zip / ISAM2DBF.PAS < prev    next >
Pascal/Delphi Source File  |  1996-04-05  |  5KB  |  161 lines
  1. unit Isam2dbf;
  2.  
  3. interface
  4.  
  5. uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
  6.   StdCtrls, Isamtabl, Gauges, DB, DBTables, ExtCtrls,
  7.   U_DbTool, Grids, DBGrids;
  8.  
  9. type
  10.   DBASEExportProc = Procedure(var DATA; DBTable: TTable; ISTable: TIsamTable);
  11.  
  12.   TTransferDlg = class(TForm)
  13.     CancelBtn: TBitBtn;
  14.     Bevel1: TBevel;
  15.     Table1: TTable;
  16.     Gauge1: TGauge;
  17.     IsamTable1: TIsamTable;
  18.     StartBttn: TBitBtn;
  19.     DataSource1: TDataSource;
  20.     DBGrid1: TDBGrid;
  21.     procedure FormDestroy(Sender: TObject);
  22.     procedure FormCreate(Sender: TObject);
  23.     procedure FormShow(Sender: TObject);
  24.     procedure StartBttnClick(Sender: TObject);
  25.   private
  26.     { Private declarations }
  27.   public
  28.     StruGetProc : Structure_GetProc;
  29.     FieldGetProc: DBASEExportProc;
  30.     Data,Dup    : Pointer;
  31.   end;
  32.  
  33. var
  34.   TransferDlg: TTransferDlg;
  35.  
  36. Procedure Isam2DBase(aParent: TForm;
  37.                      IsamTable: TIsamTable;
  38.                      DBASETableName: String;
  39.                      AliasName: String;
  40.                      Stru_Get: Structure_GetProc;
  41.                      FieldGet: DBASEExportProc);
  42.  
  43. implementation
  44.  
  45. Uses SysUtils, UToolDll, Filer;
  46.  
  47. {$R *.DFM}
  48.  
  49. Procedure Isam2DBase(aParent: TForm;
  50.                      IsamTable: TIsamTable;
  51.                      DBASETableName: String;
  52.                      AliasName: String;
  53.                      Stru_Get: Structure_GetProc;
  54.                      FieldGet: DBASEExportProc);
  55. var AktDir: String;
  56. begin
  57.   if Pos('.',DBaseTableName) > 0 then DBaseTableName:= Copy(DBaseTableName,1,Pos('.',DBaseTableName)-1);
  58.   DBaseTableName:= DBaseTableName + '.DBF';
  59.   AktDir:= ExtractFilePath(Application.ExeName);
  60.   Check_Alias(AliasName,AktDir);
  61.   TransferDlg:= TTransferDlg.Create(aParent);
  62.   Try
  63.     TransferDlg.IsamTable1:= IsamTable;
  64.     TransferDlg.Table1.DataBaseName:= AliasName;
  65.     TransferDlg.Table1.TableName:= DBaseTableName;
  66.     TransferDlg.StruGetProc:= Stru_Get;
  67.     TransferDlg.FieldGetProc:= FieldGet;
  68.     TransferDlg.ShowModal;
  69.   Finally
  70.     TransferDlg.Free;
  71.   end;
  72. end;
  73.  
  74. procedure TTransferDlg.FormDestroy(Sender: TObject);
  75. begin
  76.   FreeMem(Data,IsamTable1.RecSize);
  77.   FreeMem(Dup,IsamTable1.RecSize);
  78.   if Table1.Active then Table1.Close;
  79. end;
  80.  
  81. procedure TTransferDlg.FormCreate(Sender: TObject);
  82. begin
  83.   StruGetProc:= NIL;
  84.   FieldGetProc:= NIL;
  85.   if Sprache = 1 then CancelBtn.Caption:= 'End';
  86. end;
  87.  
  88. procedure TTransferDlg.FormShow(Sender: TObject);
  89. begin
  90.   Erzeuge_Tabelle(Self,
  91.                   Table1.DataBaseName,
  92.                   Table1.TableName,
  93.                   StruGetProc);
  94.   Table1.Open;
  95.   if Table1.Active then begin
  96.     if Table1.RecordCount > 0 then begin
  97.       if Sprache = 1 then begin
  98.         if JaNein('DBASE-Tabelle already contains data','delete data ?') then begin
  99.           Table1.Close;
  100.           Table1.EmptyTable;
  101.           Table1.Open;
  102.         end;
  103.       end
  104.       else begin
  105.         if JaNein('DBASE-Tabelle enthΣlt bereits Daten','Daten l÷schen ?') then begin
  106.           Table1.Close;
  107.           Table1.EmptyTable;
  108.           Table1.Open;
  109.         end;
  110.       end;
  111.     end;
  112.   end
  113.   else begin
  114.     if Sprache = 1 then Errorwindow('Table could not be opened','')
  115.     else Errorwindow('Tabelle konnte nicht erzeugt werden','');
  116.   end;
  117.   GetMem(Data,IsamTable1.RecSize);
  118.   GetMem(Dup,IsamTable1.RecSize);
  119. end;
  120.  
  121. procedure TTransferDlg.StartBttnClick(Sender: TObject);
  122. var i,RCount: Longint;
  123.     Altprogress,NeuProgress: Integer;
  124. begin
  125.   if Table1.Active then begin
  126.     if IsamTable1.Active then begin
  127.       RCount:= IsamTAble1.RecordCount;
  128.       IsamTable1.First(DATA^,DUP^);
  129.       i:= 0;
  130.       AltProgress:= 0;
  131.       DBGrid1.Hide;
  132.       Repeat
  133.         IsamTable1.Get(DATA^,DUP^);
  134.         if IsamOk then begin
  135.           Table1.Append;
  136.           FieldGetProc(DATA^,Table1,IsamTable1);
  137.           Table1.Post;
  138.           IsamTable1.Next(DATA^,DUP^);
  139.         end;
  140.         Inc(i);
  141.         NeuProgress:= Round((i/RCount)*100);
  142.         if AltProgress <> NeuProgress then begin
  143.           AltProgress:= NeuProgress;
  144.           Gauge1.Progress:= NeuProgress;
  145.         end;
  146.       Until (IsamOk = False) or (i = rCount);
  147.       DbGrid1.Show;
  148.     end
  149.     else begin
  150.       if Sprache = 1 then Errorwindow('Isamtable is not opened','')
  151.       else Errorwindow('Isamtabelle ist nicht ge÷ffnet','');
  152.     end;
  153.   end
  154.   else begin
  155.     if Sprache = 1 then Errorwindow('DBASE-table is not opened','')
  156.     else Errorwindow('DBASE-Tabelle ist nicht ge÷ffnet','');
  157.   end;
  158. end;
  159.  
  160. end.
  161.